Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-13/ae_14.zip/AE1.PAS

Pascal/Delphi Source File | 1991-03-08 | 22KB | 611 lines

unit AE1 ;

{$B-}
{$I-}
{$S+}
{$V-}

{-----------------------------------------------------------------------------}
{ This unit contains all basic procedures                                     }
{-----------------------------------------------------------------------------}

interface

uses Crt,Dos,AE0 ;

function UpperCase (S:string) : string ;
function WordToString (Num:word ; Len:integer) : string ;
function Wildcarded (Name : PathStr) : boolean ;
function Exists (FileName : PathStr) : boolean ;
procedure MoveToScreen (var Source,Dest ; Len : word) ;
procedure MoveFromScreen (var Source,Dest ; Len : word) ;
procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
function Grow (Index:word ; Chars:word) : boolean ;
procedure Shrink (Index:word ; Chars:word) ;
function GetCursor : byte ;
procedure SetCursor (Cursor : byte) ;
procedure CursorTo (X,Y : byte) ;
procedure WarningBeep ;
function ReadKeyNr : word ;
procedure SetBottomLine (LineText:string) ;
procedure Message (Contents:string) ;
procedure ErrorMessage (ErrorNr:byte) ;
procedure Pause ;
procedure CheckDiskError ;
procedure PutFrame (X1,Y1,X2,Y2 : byte ; Border : string) ;
procedure ClearArea (X1,Y1,X2,Y2 : byte) ;
procedure ClearWorkspace (Wsnr:byte) ;
procedure ClearKeyBuffer ;

implementation

{-----------------------------------------------------------------------------}
{ Converts all lower case letters in a string to upper case.                  }
{-----------------------------------------------------------------------------}

function UpperCase (S : string) : string ;

var Counter : word ;

begin
for Counter := 1 to Length(S) do S[Counter] := UpCase (S[Counter]) ;
UpperCase := S ;
end ;

{-----------------------------------------------------------------------------}
{ Converts an expression of type word to a string                             }
{ if Len < 0 then string is adjusted to the left; string length is <Len>      }
{ if Len > 0 then string is adjusted to the right; string length is <-Len>    }
{ if Len = 0 then string is not adjusted; string has minimum length           }
{-----------------------------------------------------------------------------}

function WordToString (Num:word ; Len:integer) : string ;

var S : string[5] ;

begin
if Len > 0
   then Str (Num:Len,S)
   else begin
        Str (Num,S) ;
        Len := - Len ;
        if (Len > 0) and (Length(S) < Len)
           then begin
                FillChar (S[Length(S)+1],Len-Length(S),' ') ;
                S[0] := Chr(Len) ;
                end ;
        end ;
WordToString := S ;
end ;

{-----------------------------------------------------------------------------}
{ Deletes all spaces on the left of a string.                                 }
{-----------------------------------------------------------------------------}

function TrimLeft (S:string) : string ;

begin
while (Length(S) >0) and (S[1] = ' ') do Delete (S,1,1) ;
TrimLeft := S ;
end ;

{-----------------------------------------------------------------------------}
{ Indicates whether a filename contains wildcard characters                   }
{-----------------------------------------------------------------------------}

function Wildcarded (Name : PathStr) : boolean ;

begin
Wildcarded := (Pos('*',Name) <> 0) or (Pos('?',Name) <> 0) ;
end ;

{-----------------------------------------------------------------------------}
{ Returns True if the file <FileName> exists, False otherwise.                }
{-----------------------------------------------------------------------------}

function Exists (FileName : PathStr) : boolean ;

var SR : SearchRec ;

begin
FindFirst (FileName,ReadOnly + Hidden + SysFile,SR) ;
Exists := (DosError = 0) and (not Wildcarded(Filename)) ;
end ;

{-----------------------------------------------------------------------------}
{ Moves <Len> bytes of memory to screen memory.                               }
{ From the TCALC spreadsheet program delivered with every copy of Turbo       }
{ Pascal 5.5                                                                  }
{-----------------------------------------------------------------------------}

procedure MoveToScreen (var Source,Dest ; Len : word) ;

external ;

{-----------------------------------------------------------------------------}
{ Moves <Len> bytes of screen memory to memory.                               }
{ From the TCALC spreadsheet program delivered with every copy of Turbo       }
{ Pascal 5.5                                                                  }
{-----------------------------------------------------------------------------}

procedure MoveFromScreen (var Source,Dest ; Len : word) ;

external ;

{$L TCMVSMEM.OBJ }

{-----------------------------------------------------------------------------}
{ Saves the contents of a rectangular part of the screen to memory.           }
{ Upper left corner is (X1,Y1), lower right is (X2,Y2)                        }
{ Also claims the amount of memory needed.                                    }
{-----------------------------------------------------------------------------}

procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;

var LineLen : byte;
    Index : word;
    Counter : byte;

begin
LineLen := X2 - X1 + 1;
GetMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
Index := 1 ;
for Counter := Y1 to Y2 do
    begin
    MoveFromScreen (DisplayPtr^[Counter,X1],MemPtr^[Index],LineLen*2);
    Inc (Index,LineLen)
    end;
{$IFDEF DEVELOP }
if MemAvail < MinMemAvail
   then MinMemAvail := MemAvail ;
{$ENDIF }
end;

{-----------------------------------------------------------------------------}
{ Reverse of SaveArea                                                         }
{-----------------------------------------------------------------------------}

procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;

var LineLen : byte;
    Index : word;
    Counter : byte;

begin
LineLen := X2 - X1 + 1;
Index := 1;
for Counter := Y1 to Y2 do
    begin
    MoveToScreen (MemPtr^[Index],DisplayPtr^[Counter,X1],LineLen*2);
    Inc (Index,LineLen)
    end;
FreeMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
end;

{-----------------------------------------------------------------------------}
{ Expands the text in the buffer of the current workspace at position         }
{ <Index> by <Chars> characters. Function result is False if there is not     }
{ enough space left, True otherwise.                                          }
{ Index values of Mark and in position stack are adapted                      }
{-----------------------------------------------------------------------------}

function Grow (Index:word ; Chars:word) : boolean ;

var Counter : byte ;

begin
with Workspace[CurrentWsnr] do
     if Chars > (WsBufSize - BufferSize)
        then begin
             { not enough space }
             ErrorMessage (1) ;
             Grow := False ;
             end
        else begin
             { move rest of text forward }
             Move (Buffer^[Index],Buffer^[Index+Chars],BufferSize-Index+1) ;
             Inc (BufferSize,Chars) ;
             { adapt Mark and position stack }
             if Mark >= Index then Inc (Mark,Chars) ;
             for Counter := 1 to PosStackpointer do
                 begin
                 if PosStack[Counter] >= Index
                    then Inc (PosStack[Counter],Chars) ;
                 end ;
             ChangesMade := True ;
             Grow := True ;
             end ;
end ;

{-----------------------------------------------------------------------------}
{ Deletes <Chars> characters from the buffer in the current workspace,        }
{ starting on position <Index>.                                               }
{ Index values of Mark and in position stack are adapted                      }
{-----------------------------------------------------------------------------}

procedure Shrink (Index:word ; Chars:word) ;

var Counter : word ;

begin
with Workspace[CurrentWsnr] do
     begin
     { move rest of text backward }
     Move (Buffer^[Index+Chars],Buffer^[Index],BufferSize-(Index+Chars)+1) ;
     Dec (BufferSize,Chars) ;
     { adapt Mark }
     if (Mark >= Index)
        then begin
             if (Mark < (Index+Chars))
                then Mark := Inactive
                else Dec (Mark,Chars) ;
             end ;
     { adapt position stack }
     for Counter := 1 to PosStackpointer do
         if (PosStack[Counter] >= Index)
            then begin
                 if (PosStack[Counter] < (Index+Chars))
                    then PosStack[Counter] := Index
                    else Dec (PosStack[Counter],Chars) ;
                 end ;
     ChangesMade := True ;
     end ;
end ;

{-----------------------------------------------------------------------------}
{ Returns the current cursor type                                             }
{-----------------------------------------------------------------------------}

function GetCursor : byte ;

var Reg : registers ;

begin
with Reg do
     begin
     AH := 3 ;
     BH := 0 ;
     { call BIOS interrupt }
     Intr ($10,Reg) ;
     case CX of
          $0607,$0B0C : GetCursor := UnderLineCursor ;
          $0507,$090C : GetCursor := HalfBlockCursor ;
          $0807,$0D0C : GetCursor := BlockCursor ;
          $2000       : GetCursor := Inactive ;
          $2001       : GetCursor := NoBlinkCursor ;
          else          GetCursor := UnderLineCursor ;
          end ; { of case }
     end ; { of with }
end ;

{-----------------------------------------------------------------------------}
{ Sets a new cursor                                                           }
{-----------------------------------------------------------------------------}

procedure SetCursor (Cursor : byte) ;

var Reg : registers ;
    ScrEl : ScreenElement ;

begin
if Config.Setup.CursorType = NoBlinkCursor
   then begin
        { remove NoBlinkCursor from old position: reset attribute }
        ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
        ScrEl.attribute := OldCursorPosAttr ;
        DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
        end ;
with Reg do
     begin
     AH := 1 ;
     BH := 0 ;
     { monochrome and color cards require different settings for cursor shape }
     case Cursor of
          Inactive        : CX := $2000 ;
          UnderLineCursor : if Colorcard then CX := $0607 else CX := $0B0C ;
          HalfBlockCursor : if Colorcard then CX := $0507 else CX := $090C;
          BlockCursor     : if Colorcard then CX := $0807 else CX := $0D0C ;
          NoBlinkCursor   : CX := $2001 ;
          end ; { of case }
     { call BIOS interrupt }
     Intr ($10,Reg) ;
     end ; { with }
if Cursor = NoBlinkCursor
   then begin
        { put NoBlinkCursor on new position }
        ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
        { save original attribute }
        OldCursorPosAttr := ScrEl.attribute ;
        { set cursor attribute }
        with ScreenColorArray[Config.Setup.ScreenColors] do
             ScrEl.Attribute := CursorAttr ;
        DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
        end ;
end ;

{-----------------------------------------------------------------------------}
{ Positions the cursor at (X,Y)                                               }
{-----------------------------------------------------------------------------}

procedure CursorTo (X,Y : byte) ;

var ScrEl : ScreenElement ;

begin
if Config.Setup.CursorType = NoBlinkCursor
   then begin
        { remove NoBlinkCursor from old position: reset attribute }
        ScrEl := ScreenElement (DisplayPtr^[WhereY,WhereX]) ;
        ScrEl.attribute := OldCursorPosAttr ;
        DisplayPtr^[WhereY,WhereX] := word (ScrEl) ;
        end ;
GotoXY (X,Y) ;
if Config.Setup.CursorType = NoBlinkCursor
   then begin
        { put NoBlinkCursor on new position }
        ScrEl := ScreenElement (DisplayPtr^[Y,X]) ;
        { save original attribute }
        OldCursorPosAttr := ScrEl.attribute ;
        { set cursor attribute }
        with ScreenColorArray[Config.Setup.ScreenColors] do
             ScrEl.Attribute := CursorAttr ;
        DisplayPtr^[Y,X] := word (ScrEl) ;
        end ;
end ;

{-----------------------------------------------------------------------------}
{ Produces a low beep trough the speaker, unless inhibited by Setup           }
{-----------------------------------------------------------------------------}

procedure WarningBeep ;

begin
if Config.Setup.SoundBell
   then begin
        Sound (110) ;
        Delay (100) ;
        NoSound ;
        end ;
end ;

{-----------------------------------------------------------------------------}
{ Waits until a key on the keyboard is pressed and returns its key number.    }
{ Control keys (cursor keys, function keys etc.) are translated to numbers    }
{ above 255.                                                                  }
{-----------------------------------------------------------------------------}

function ReadKeyNr : word ;

var Regs : registers ;

begin
with Regs do
     begin
     AH := 0 ;
     Intr ($16,Regs) ;
     { AL now contains the ASCII value of the key, AH the scan code }
     case AL of
           0 : if AH = 3  then ReadKeyNr := 0    { ^@ }
                          else ReadKeyNr := 256 + AH ;
           8 : if AH = 14 then ReadKeyNr := BkspKey
                          else ReadKeyNr := 8 ;  { ^H }
           9 : if AH = 15 then ReadKeyNr := TabKey
                          else ReadKeyNr := 9 ;  { ^I }
          10 : if AH = 28 then ReadKeyNr := CtrlReturnKey
                          else ReadKeyNr := 10 ; { ^J }
          13 : if AH = 28 then ReadKeyNr := ReturnKey
                          else ReadKeyNr := 13 ; { ^M }
          27 : if AH = 1  then ReadKeyNr := EscapeKey
                          else ReadKeyNr := 27 ; { ^[ }
          else ReadKeyNr := AL ;
          end ; { of case }
     end ; { of with }
end ;

{-----------------------------------------------------------------------------}
{ Puts a line of text on the last line of the screen.                         }
{ Writes directly into video memory.                                          }
{-----------------------------------------------------------------------------}

procedure SetBottomLine (LineText:string) ;

var ScrEl : ScreenElement ;
    Col : byte ;
    NewBottomLine : array[1..ColsOnScreen] of ScreenElement ;

begin
{ fill rest of LineText with spaces until length = ColsOnScreen }
for Col := (Length(LineText)+1) to ColsOnScreen do
    LineText[Col] := ' ' ;
LineText[0] := char(ColsOnScreen) ;
{ set attribute }
ScrEl.Attribute := ScreenColorArray[Config.Setup.ScreenColors].StatusAttr ;
{ fill bottom line of screen }
for Col := 1 to ColsOnScreen do
    begin
    ScrEl.Contents := LineText[Col] ;
    NewBottomLine[Col] := ScrEl ;
    end ;
MoveToScreen (NewBottomLine[1],DisplayPtr^[LinesOnScreen,1],2*ColsOnScreen) ;
end ;

{-----------------------------------------------------------------------------}
{ Produces a message on the last line of the screen and sets MessageRead      }
{-----------------------------------------------------------------------------}

procedure Message (Contents:string) ;

begin
SetBottomLine (Contents) ;
MessageRead := (Length(Contents) = 0) ;
end ;

{-----------------------------------------------------------------------------}
{ Produces an error beep (if allowed by Setup), writes an error message       }
{ corresponding to the error number, on the last screen line and waits        }
{ until the Escape key is pressed.                                            }
{ If any macros are running, they are canceled.                               }
{-----------------------------------------------------------------------------}

procedure ErrorMessage (ErrorNr:byte) ;

var ErrorText : string[ColsOnScreen] ;

begin
if Config.Setup.SoundBell
   then begin
        Sound(880) ;
        Delay(100) ;
        NoSound ;
        end ;
case ErrorNr of
       1 : ErrorText := 'Not enough memory' ;
       4 : ErrorText := 'Block too large for paste buffer' ;
       5 : ErrorText := 'No block defined' ;
       6 : ErrorText := 'Maximum macro length reached. End of define mode' ;
       7 : ErrorText := 'File too large. Only partially read' ;
       8 : ErrorText := 'File not found' ;
       9 : ErrorText := 'Cyclic macro definition. Key ignored' ;
      10 : ErrorText := 'Too many macros nested. Execution canceled' ;
      11 : ErrorText := 'Not in word wrap mode' ;
      12 : ErrorText := 'Position stack full' ;
      13 : ErrorText := 'Position stack empty' ;
      14 : case DosError of
                2  : ErrorText := 'Can not find COMMAND.COM ' ;
                8  : ErrorText := 'Not enough memory to execute DOS command' ;
                else ErrorText := 'DOS error '+WordToString(DosError,2) ;
                end ; { of case }
      15 : ErrorText := 'String not found' ;
      16 : ErrorText := 'Illegal file name' ;
      17 : case DiskError of
                2   : ErrorText := 'File not found' ;
                3   : ErrorText := 'Path not found' ;
                5   : ErrorText := 'File acces denied' ;
                101 : ErrorText := 'Disk write error' ;
                150 : ErrorText := 'Disk is write-protected' ;
                152 : ErrorText := 'Drive not ready' ;
                159 : ErrorText := 'Printer out of paper' ;
                160 : ErrorText := 'Device write fault' ;
                else  ErrorText := 'I/O error ' + WordToString (DiskError,0) ;
                end ; { of case }
      end ; { of case }
SetBottomLine (ErrorText+' (press Esc)') ;
repeat until ReadKeyNr = EscapeKey ;
if MacroStackpointer <> Inactive
   then begin
        MacroStackpointer := Inactive ;
        Message ('Macro execution canceled') ;
        end
   else Message ('') ;
end ;

{-----------------------------------------------------------------------------}
{ Like the DOS batch command, Pause displays the message 'Press any key to    }
{ continue' and then waits until a key is pressed.                            }
{-----------------------------------------------------------------------------}

procedure Pause ;

var DummyKey : word ;

begin
SetBottomLine ('Press any key to continue') ;
DummyKey := ReadKeyNr ;
EscPressed := (DummyKey = EscapeKey) ;
SetBottomLine ('') ;
end ;

{-----------------------------------------------------------------------------}
{ Reads the result of the last I/O operation into the DiskError variable      }
{ and produces an error message if an error has occurred.                     }
{-----------------------------------------------------------------------------}

procedure CheckDiskError ;

begin
DiskError := IOResult ;
if DiskError <> 0 then ErrorMessage (17) ;
end ;

{-----------------------------------------------------------------------------}
{ Draws a frame on the text screen between (X1,Y1) and (X2,Y2)                }
{-----------------------------------------------------------------------------}

procedure PutFrame (X1,Y1,X2,Y2 : byte ; Border : string) ;

var i : byte ;

begin
CursorTo (X1,Y1) ; Write (Border[1]) ; { upper left corner }
for i := Succ(X1) to Pred(X2) do Write (Border[2]) ; { upper side }
Write (Border[3]) ; { upper right corner }
for i := Succ(Y1) to Pred(Y2) do
    begin
    CursorTo (X1,i) ; Write (Border[8]) ; { left side }
    CursorTo (X2,i) ; Write (Border[4]) ; { right side }
    end ;
CursorTo (X1,Y2) ; Write (Border[7]) ; { lower right corner }
for i := Succ(X1) to Pred(X2) do Write (Border[6]) ; { lower side }
Write (Border[5]) ; { lower left corner }
end ;

{-----------------------------------------------------------------------------}
{ Clears a rectangular screen area between (X1,Y1) and (X2,Y2).               }
{-----------------------------------------------------------------------------}

procedure ClearArea (X1,Y1,X2,Y2 : byte) ;

var OldWindMax,OldWindMin : word ;

begin
OldWindMax := WindMax ;
OldWindMin := WindMin ;
Window (X1,Y1,X2,Y2) ;
ClrScr ;
Window (Lo(OldWindMin)+1,Hi(OldWindMin)+1,
        Lo(OldWindMax)+1,Hi(OldWindMax)+1) ;
end ;

{-----------------------------------------------------------------------------}
{ Clears the workspace indicated by <Wsnr>, resetting all variables.          }
{-----------------------------------------------------------------------------}

procedure ClearWorkspace (Wsnr:byte) ;

begin
with Workspace[Wsnr] do
     begin
     Name := '' ;
     ChangesMade := False ;
     GetTime (LastTimeSaved[1],LastTimeSaved[2],
              LastTimeSaved[3],LastTimeSaved[4]) ;
     CurPos.Index := 1 ;
     CurPos.Linenr := 1 ;
     CurPos.Colnr := 1 ;
     Mark := Inactive ;
     FirstVisiblePos := CurPos ;
     FirstScreenCol := 1 ;
     VirtualColnr := 1 ;
     Buffer^[1] := EF ;
     Buffersize := 1 ;
     PosStackPointer := Inactive ;
     end ;
end ;

{-----------------------------------------------------------------------------}
{ Clears the keys in the keyboard buffer.                                     }
{-----------------------------------------------------------------------------}

procedure ClearKeyBuffer ;

var DummyKey : char ;

begin
while KeyPressed do DummyKey := ReadKey ;
end ;

{-----------------------------------------------------------------------------}

end.